home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / scainit.scm < prev    next >
Text File  |  1999-04-19  |  3KB  |  105 lines
  1. ;;; "scainit.scm" Syntax-case macros port to SLIB    -*- Scheme -*-
  2. ;;; Copyright (C) 1992 R. Kent Dybvig
  3. ;;;
  4. ;;; Permission to copy this software, in whole or in part, to use this
  5. ;;; software for any lawful purpose, and to redistribute this software
  6. ;;; is granted subject to the restriction that all copies made of this
  7. ;;; software must include this copyright notice in full.  This software
  8. ;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED,
  9. ;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY
  10. ;;; OR FITNESS FOR ANY PARTICULAR PURPOSE.  IN NO EVENT SHALL THE
  11. ;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY
  12. ;;; NATURE WHATSOEVER.
  13.  
  14. ;;; From: Harald Hanche-Olsen <hanche@imf.unit.no>
  15.  
  16. ;;; compat.ss
  17. ;;; Robert Hieb & Kent Dybvig
  18. ;;; 92/06/18
  19.  
  20. (require 'common-list-functions)    ;to pick up EVERY
  21. (define syncase:andmap comlist:every)
  22.  
  23. ; In Chez Scheme "(syncase:void)" returns an object that is ignored by the
  24. ; REP loop.  It is returned whenever a "nonspecified" value is specified
  25. ; by the standard.  The following should pick up an appropriate value.
  26.  
  27. (define syncase:void
  28.    (let ((syncase:void-object (if #f #f)))
  29.       (lambda () syncase:void-object)))
  30.  
  31. (define syncase:eval-hook slib:eval)
  32.  
  33. (define syncase:error-hook slib:error)
  34.  
  35. (define syncase:new-symbol-hook
  36.   (let ((c 0))
  37.     (lambda (string)
  38.       (set! c (+ c 1))
  39.       (string->symbol
  40.        (string-append string ":Sca" (number->string c))))))
  41.  
  42. (define syncase:put-global-definition-hook #f)
  43. (define syncase:get-global-definition-hook #f)
  44. (let ((*macros* '()))
  45.   (set! syncase:put-global-definition-hook
  46.     (lambda (symbol binding)
  47.       (let ((pair (assq symbol *macros*)))
  48.         (if pair
  49.         (set-cdr! pair binding)
  50.         (set! *macros* (cons (cons symbol binding) *macros*))))))
  51.   (set! syncase:get-global-definition-hook
  52.     (lambda (symbol)
  53.       (let ((pair (assq symbol *macros*)))
  54.         (and pair (cdr pair))))))
  55.  
  56.  
  57. ;;;! expand.pp requires list*
  58. (define (syncase:list* . args)
  59.   (if (null? args)
  60.       '()
  61.       (let ((r (reverse args)))
  62.     (append (reverse (cdr r))
  63.         (car r)            ; Last arg
  64.         '()))))            ; Make sure the last arg is copied
  65.  
  66. (define syntax-error syncase:error-hook)
  67. (define impl-error slib:error)
  68.  
  69. (define base:eval slib:eval)
  70. (define syncase:eval base:eval)
  71. (define macro:eval base:eval)
  72. (define syncase:expand #f)
  73. (define macro:expand #f)
  74. (define (syncase:expand-install-hook expand)
  75.   (set! syncase:eval (lambda (x) (base:eval (expand x))))
  76.   (set! macro:eval syncase:eval)
  77.   (set! syncase:expand expand)
  78.   (set! macro:expand syncase:expand))
  79. ;;; We Need This for bootstrapping purposes:
  80. (define (syncase:load <pathname>)
  81.   (slib:eval-load <pathname> syncase:eval))
  82. (define macro:load syncase:load)
  83.  
  84. (define syncase:sanity-check #f)
  85. ;;; LOADING THE SYSTEM ITSELF:
  86. (let ((here (lambda (file)
  87.           (in-vicinity (library-vicinity) file)))
  88.       (scmhere (lambda (file)
  89.          (in-vicinity (library-vicinity)
  90.                   (string-append file (scheme-file-suffix))))))
  91.   (for-each (lambda (file) (slib:load (here file)))
  92.         '("scaoutp"
  93.           "scaglob"
  94.           "scaexpp"))
  95.   (syncase:expand-install-hook expand-syntax)
  96.   (syncase:load (here "scamacr"))
  97.   (set! syncase:sanity-check
  98.     (lambda ()
  99.       (syncase:load (scmhere "sca-exp"))
  100.       (syncase:expand-install-hook expand-syntax)
  101.       (syncase:load (scmhere "sca-macr")))))
  102.  
  103. (provide 'syntax-case)
  104. (provide 'macro)
  105.